home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Text / Emacs-1.12d folder / lisp / mac / apple-events.el next >
Encoding:
Text File  |  1993-12-29  |  8.5 KB  |  265 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; Utilities for Apple event calls
  6. ;;;
  7.  
  8. (defun ae-extract-args (key arglist)
  9.   (cond
  10.    ((null arglist)
  11.     nil)
  12.    ((eq (car (car arglist)) key)
  13.     (cons (car (cdr (car arglist))) (ae-extract-args key (cdr arglist))))
  14.    (t
  15.     (ae-extract-args key (cdr arglist)))))
  16.  
  17. (defun ae-generate-outs (n outs)
  18.   (cond
  19.    ((null outs)
  20.     nil)
  21.    (t
  22.     (cons
  23.      (list 'list ''setq (car outs) (list 'list ''nth n ''temp))
  24.      (ae-generate-outs (1+ n) (cdr outs))))))
  25.  
  26. (defun ae-create-interface (func arglist)
  27.   (let ((ins (ae-extract-args 'in arglist))
  28.         (outs (ae-extract-args 'out arglist)))
  29.     (list 'defmacro
  30.           func
  31.           (mapcar (function (lambda (x) (car (cdr x)))) arglist)
  32.           (append
  33.            (list 'list ''let
  34.                  (list 'list
  35.                        (list 'list ''temp
  36.                              (append
  37.                               (list 'list
  38.                                     (list 'quote
  39.                                           (intern (concat (symbol-name func)
  40.                                                           "-internal")))) ins))))
  41.            (ae-generate-outs 0 outs)
  42.            (list (list 'list ''nthcdr (length outs) ''temp))))))
  43.  
  44. (eval (ae-create-interface 'CreateObjSpecifier '((in desiredClass)
  45.                                                  (in theContainer)
  46.                                                  (in keyForm)
  47.                                                  (in keyData)
  48.                                                  (in disposeInputs)
  49.                                                  (out objSpecifier))))
  50.  
  51. (eval (ae-create-interface 'unix-filename-to-FSSpec '((in filename)
  52.                                                       (out spec))))
  53.  
  54. (defun make-init-string (base len)
  55.   (ae-extract "string" base 0 len))
  56.  
  57. (defun deref (address)
  58.   (ae-extract typeLongInteger address 0))
  59.  
  60. ;;;
  61. ;;; A macro we use in construction of Apple events.
  62. ;;; We should eventually rewrite this using signal.
  63. ;;;
  64.  
  65. (defmacro catch-err (form &optional condition)
  66.   (list 'let (list (list 'err form))
  67.         (list 'if (or condition '(not (zerop err))) (list 'throw ''bailout 'err))))
  68.  
  69. ;;;
  70. ;;; A convenient way to create Apple events to a specific target
  71. ;;;
  72.  
  73. (defun ae-create-apple-event-internal (targetID eventClass eventID)
  74.   (let* ((target (make-string sizeof-AEDesc 0))
  75.          have-target
  76.          (event (make-string sizeof-AppleEvent 0))
  77.          have-event
  78.          (actualSize (make-string 4 0))
  79.          (resultType (make-string 4 0))
  80.          (transactionID (make-string 4 0))
  81.          (result
  82.           (catch 'bailout
  83.             (catch-err (AECreateDesc typeApplSignature targetID 4 target))
  84.             (setq have-target t)
  85.             (catch-err (AECreateAppleEvent eventClass eventID target
  86.                                            kAutoGenerateReturnID
  87.                                            kAnyTransactionID event))
  88.             (setq have-event t)
  89.             (catch-err (AEGetAttributePtr event keyReturnIDAttr typeLongInteger
  90.                                           resultType transactionID 4 actualSize))
  91.             noErr)))
  92.     (if have-target (AEDisposeDesc target))
  93.     (if (zerop result)
  94.         (cons result (cons event (ae-extract typeLongInteger transactionID 0)))
  95.       (cons result (cons nil nil)))))
  96.  
  97. (defmacro ae-create-apple-event (targetID eventClass eventID event transactionID)
  98.   (` (let ((temp (ae-create-apple-event-internal (, targetID)
  99.                                                  (, eventClass) (, eventID))))
  100.        (setq (, event) (car (cdr temp)))
  101.        (setq (, transactionID) (cdr (cdr temp)))
  102.        (car temp))))
  103.  
  104. (defvar ae-history nil "A list of Apple events sent from Emacs.  This list is used to associate replies.")
  105.  
  106. (defun AliasHandle-aliasSize (ah)
  107.   (HLock ah)
  108.   (unwind-protect
  109.       (let ((s (make-init-string (deref ah) 6)))
  110.         (ae-extract typeShortInteger s 4))
  111.     (HUnlock ah)))
  112.  
  113. (defun ae-have-required-parameters (event)
  114.   (let* ((actualSize (make-string 4 0))
  115.          (resultType (make-string 4 0))
  116.          (data (make-string 0 0))
  117.          (err (AEGetAttributePtr event keyMissedKeywordAttr typeWildCard
  118.                                  returnedType data 0 actualSize)))
  119.     (cond
  120.      ((= err errAEDescNotFound)
  121.       noErr)
  122.      ((= err noErr)
  123.       errAEEventNotHandled)
  124.      (t
  125.       err))))
  126.  
  127. (defun short-time-string ()
  128.   "Returns a string representing the time of day."
  129.   (let* ((s (current-time-string))
  130.          (blank-3 10)
  131.          (blank-4 19))
  132.     (substring s (1+ blank-3) blank-4)))
  133.  
  134. (defun insert-reply (&rest s)
  135.   (let ((errors-buffer (get-buffer-create "*replies*"))
  136.         (original-window (selected-window)))
  137.     (if (not (get-buffer-window errors-buffer))
  138.         (let ((errors-window 
  139.                (if (eq (next-window) original-window)
  140.                    (split-window original-window
  141.                                  (- (window-height (selected-window)) 8))
  142.                  (display-buffer errors-buffer))))
  143.           (set-window-buffer errors-window errors-buffer)))
  144.     (select-window (get-buffer-window errors-buffer))
  145.     (set-buffer errors-buffer)
  146.     (goto-char (point-max))
  147.     (apply (function insert) s)
  148.     (goto-char (point-max))
  149.     (select-window original-window)))
  150.  
  151. (defun do-ae-answer (event reply refCon)
  152.   (let* ((actualSize (make-string 4 0))
  153.          (resultType (make-string 4 0))
  154.          (transactionID-string (make-string 4 0))
  155.          (err (AEGetAttributePtr event keyReturnIDAttr typeLongInteger
  156.                                  resultType transactionID-string 4 actualSize)))
  157.     (if (not (zerop err))
  158.         (insert-reply "Received a reply, but cannot determine original request\n")
  159.       (let* ((transactionID-number (ae-extract typeLongInteger transactionID-string 0))
  160.              (history (assoc transactionID-number ae-history)))
  161.         (if (not history)
  162.             (insert-reply "Received a reply with ID "
  163.                           (int-to-string transactionID-number)
  164.                           ", but cannot determine original request\n")
  165.           (let ((handler (cdr (assoc 'handler (cdr history)))))
  166.             (if handler
  167.                 (funcall handler event history)
  168.               noErr)))))))
  169.  
  170. ;;;
  171. ;;; A simple reply handler
  172. ;;;
  173.  
  174. (defun announce-reply (history)
  175.   (let ((description (cdr (assoc 'description (cdr history)))))
  176.     (insert-reply "Reply at " (short-time-string)
  177.                   (if description (concat " to “" description "”") "")
  178.                   ":\n")))
  179.  
  180. (defun do-simple-reply (event history)
  181.   (announce-reply history)
  182.   (let* ((error-number-data (make-string 4 0))
  183.          (returnedType (make-string 4 0))
  184.          (actualSize (make-string 4 0))
  185.          (err (AEGetParamPtr event keyErrorNumber typeLongInteger returnedType
  186.                              error-number-data (length error-number-data) actualSize)))
  187.     (cond
  188.      ((zerop err)
  189.       (let ((error-number (ae-extract typeLongInteger error-number-data 0)))
  190.         (insert-reply "  Error " (error-string error-number) "\n"))
  191.       noErr)
  192.      ((= err errAEDescNotFound)
  193.       (insert-reply "  No data was sent in reply.\n")
  194.       noErr)
  195.      (t
  196.       (insert-reply "  Could not read result, got error " (error-string err) ".\n")
  197.       err))))
  198.  
  199. (defun error-string (error-number)
  200.   (concat (int-to-string error-number)
  201.           (let ((s (lookup-error-string error-number)))
  202.             (if s (concat ", “" s "”") ""))))
  203.  
  204. (defun report-error-in-message-line (err)
  205.   (if (not (zerop err))
  206.       (let ((error-string (lookup-error-string err)))
  207.     (message (concat "While sending Apple event, got error "
  208.              (int-to-string err)
  209.              (if error-string (concat ", “" error-string "”") ""))))))
  210.  
  211. (defun launch-application (name)
  212.   "Launch the application named APPLICATION in ~/etc."
  213.   (let* (target
  214.          event
  215.          have-event
  216.          (reply (make-string sizeof-AppleEvent 0))
  217.          transactionID
  218.          spec
  219.          (alias-string (make-string 4 0))
  220.          alias-handle
  221.          alias-data
  222.          (ae-list (make-string sizeof-AEDescList 0))
  223.          have-ae-list
  224.          (result
  225.           (catch 'bailout
  226.             (progn
  227.               (catch-err (ae-create-apple-event "MACS" kAEFinderEvents kAEOpenSelection
  228.                                                 event transactionID))
  229.               (setq have-event t)
  230.  
  231.               (catch-err (unix-filename-to-FSSpec "/bin" spec))
  232.               (catch-err (NewAlias 0 spec alias-string))
  233.               (setq alias-handle (ae-extract typeLongInteger alias-string 0))
  234.               (HLock alias-handle)
  235.               (setq alias-data (make-init-string (deref alias-handle)
  236.                                                  (AliasHandle-aliasSize alias-handle)))
  237.               (DisposHandle alias-handle)
  238.               (catch-err (AEPutParamPtr event keyDirectObject typeAlias
  239.                                         alias-data (length alias-data)))
  240.               
  241.               (catch-err (unix-filename-to-FSSpec (concat "/bin/" name) spec))
  242.               (catch-err (NewAliasMinimal spec alias-string))
  243.               (setq alias-handle (ae-extract typeLongInteger alias-string 0))
  244.               (HLock alias-handle)
  245.               (setq alias-data (make-init-string (deref alias-handle)
  246.                                                  (AliasHandle-aliasSize alias-handle)))
  247.               (DisposHandle alias-handle)
  248.               (catch-err (AECreateList 0 0 0 ae-list))
  249.               (setq have-ae-list t)
  250.               (catch-err (AEPutPtr ae-list 0 typeAlias alias-data (length alias-data)))
  251.               (catch-err (AEPutParamDesc event keySelection ae-list))
  252.             
  253.               (catch-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
  254.                                  kAENormalPriority kAEDefaultTimeout 0 0))
  255.               (setq ae-history (cons (cons transactionID
  256.                                            (list
  257.                                             (cons 'description (concat "launch " name))))
  258.                                      ae-history))
  259.               noErr))))
  260.     (if have-event (AEDisposeDesc event))
  261.     (if have-ae-list (AEDisposeDesc ae-list))
  262.     result))
  263.     
  264. (AEInstallEventHandler kCoreEventClass kAEAnswer 'do-ae-answer 0 0)
  265.